home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / link / mipscosuspend.t < prev    next >
Text File  |  1990-10-15  |  12KB  |  352 lines
  1. (herald mipscosuspend (env tsys (link suspend)))
  2.  
  3. ;;; Look at a Unix a.out description and template.doc
  4.  
  5. (define (set-up-the-slink)
  6.   (modify (+area-frontier (lstate-impure *lstate*))
  7.           (lambda (x) (fx+ (fx+ x %%slink-size) %%stack-size)))
  8.   (let ((null 
  9.          (object nil
  10.            ((heap-stored self) (lstate-impure *lstate*))
  11.            ((heap-offset self) (fx+ %%stack-size tag/pair))
  12.            ((write-descriptor self stream)
  13.             (write-data stream (fx+ %%stack-size tag/pair)))
  14.            ((write-store self stream)
  15.         (do ((i 0 (fx+ i 4)))
  16.         ((fx= i %%stack-size))
  17.           (write-int stream 0))
  18.             (let ((pi (fx+ slink/initial-pure-memory-begin 3)))
  19.               (do ((i 0 (fx+ i 4)))
  20.                   ((fx= i pi)
  21.                    (write-int stream 0)
  22.                    (write-int stream (+area-frontier (lstate-pure *lstate*)))
  23.                    (write-data stream %%stack-size)
  24.                    (write-data stream (+area-frontier (lstate-impure *lstate*)))
  25.                    (write-int stream (fx-ashl (fx+ (gc-stamp) 1) 2))
  26.                    (do ((i (fx+ i 20) (fx+ i 4)))
  27.                        ((fx= i %%slink-size))
  28.                      (write-int stream 0)))
  29.                 (write-int stream 0)))))))
  30.     (set (lstate-null *lstate*) null)
  31.     (push (+area-objects (lstate-impure *lstate*)) null)
  32.     (text-relocation (fx+ %%stack-size
  33.               (fx+ slink/initial-pure-memory-begin 3)))
  34.     (text-relocation (fx+ %%stack-size (fx+ slink/initial-pure-memory-end 3)))
  35.     (data-relocation (fx+ %%stack-size
  36.               (fx+ slink/initial-impure-memory-begin 3)))
  37.     (data-relocation (fx+ %%stack-size (fx+ slink/initial-impure-memory-end 3)))
  38.     null))
  39.  
  40. (define (suspend obj out-spec x?)
  41.   (set (experimental?) x?)
  42.   (really-suspend obj out-spec 'o))
  43.  
  44.  
  45. (define-constant RELOC-SIZE 8)
  46. (define-constant MAGIC #x160)
  47. (define-constant TEXT-SYM 1)
  48. (define-constant DATA-SYM 3)
  49.  
  50. (lset reloc-length 0)
  51. (lset pure-size 0)
  52.  
  53.  
  54. (define (vgc-foreign foreign)
  55.   (let* ((heap (lstate-impure *lstate*))
  56.          (addr (+area-frontier heap))
  57.          (name (foreign-name foreign))
  58.          (desc (object nil
  59.                  ((heap-stored self) (lstate-impure *lstate*))
  60.                  ((heap-offset self) addr)
  61.                  ((write-descriptor self stream)
  62.                   (write-data stream (fx+ addr tag/extend)))
  63.                  ((write-store self stream)
  64.                   (write-int stream header/foreign)
  65.                   (write-slot name stream)
  66.                   (write-int stream 0)))))
  67.     (set (+area-frontier heap) (fx+ addr 12))
  68.     (push (+area-objects heap) desc)
  69.     (set-lp-table-entry (lstate-reloc *lstate*) foreign desc)
  70.     (generate-slot-relocation name (fx+ addr 4))
  71.     (cymbal-thunk (symbol->string name)  0)
  72.     (reloc-thunk (fx+ addr 8)
  73.          (lstate-symbol-count *lstate*)
  74.          5)
  75.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  76.     desc))
  77.  
  78.  
  79. (define (generate-slot-relocation obj slot-address)
  80.   (cond ((or (fixnum? obj) (immediate? obj)))
  81.         ((eq? (heap-stored (vgc obj)) (lstate-impure *lstate*))
  82.          (reloc-thunk slot-address DATA-SYM 4))
  83.         (else
  84.          (reloc-thunk slot-address TEXT-SYM 4))))
  85.  
  86. (define (text-relocation addr)
  87.   (reloc-thunk addr TEXT-SYM 4))
  88.  
  89. (define (data-relocation addr)
  90.   (reloc-thunk addr DATA-SYM 4))
  91.  
  92. (define (reloc-thunk address lw hb)
  93.   (push (lstate-data-reloc *lstate*)
  94.         (cons address (cons lw hb))))
  95.  
  96. (lset the-string-table nil)
  97.  
  98. (define (write-slot obj stream)
  99.   (cond ((fixnum? obj)
  100.          (write-fixnum stream obj))
  101.         ((immediate? obj)
  102.          (write-immediate stream obj))
  103.         ((null? obj)
  104.          (write-descriptor (lstate-null *lstate*) stream))
  105.         ((lp-table-entry (lstate-reloc *lstate*) obj)
  106.          => (lambda (desc) (write-descriptor desc stream)))
  107.         (else
  108.          (write-descriptor (lstate-null *lstate*) stream))))
  109.  
  110.  
  111.  
  112. (define-integrable (write-data stream int)
  113.   (write-int stream (fx+ pure-size int)))
  114.  
  115. (define (write-immediate stream imm)
  116.   (let ((int (descriptor->fixnum imm)))
  117.     (write-half stream (fixnum-ashr int 14))
  118.     (write-half stream (fx+ (fixnum-ashl int 2) 1))))
  119.  
  120.  
  121. (define (write-scratch stream obj i)
  122.   (let ((offset (fixnum-ashl i 2)))
  123.     (write-half stream (mref-16-u obj offset))
  124.     (write-half stream (mref-16-u obj (fx+ offset 2)))))
  125.  
  126. (define (write-int stream int)
  127.   (write-half stream (fixnum-ashr int 16))
  128.   (write-half stream int))
  129.  
  130. (define (write-half stream int)
  131.   (vm-write-byte stream (fixnum-ashr int 8))
  132.   (vm-write-byte stream int))
  133.  
  134. (define (write-fixnum stream fixnum)
  135.   (write-half stream (fixnum-ashr fixnum 14))
  136.   (write-half stream (fixnum-ashl fixnum 2)))
  137.  
  138. (define (cymbal-thunk stryng value)
  139.  (push (lstate-symbols *lstate*)
  140.   (object (lambda (stream)
  141.         (write-int stream 0)
  142.         (write-int stream (table-entry the-string-table stryng))
  143.             (cond ((fx= value 0)            ; undefined external (foreign)
  144.            (write-int stream 0)
  145.            (write-half stream #x4cf))
  146.           (else
  147.            (write-descriptor value stream)
  148.            (write-half stream #x44f)))
  149.         (write-half stream #xffff))
  150.           ((cymbal-thunk.stryng self) stryng))))
  151.  
  152. (define-operation (cymbal-thunk.stryng thunk))
  153.  
  154. (define (make-global-cymbal proc name)
  155.   (cond ((lp-table-entry (lstate-reloc *lstate*) proc)
  156.        => (lambda (desc)                                
  157.             (cymbal-thunk (string-downcase! (symbol->string name))
  158.                           desc)
  159.             (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))))
  160.         (else
  161.          (error "~s not defined" name))))
  162.  
  163. (define (write-link-file stream)
  164.   (make-global-cymbal big_bang 'big_bang)
  165.   (make-global-cymbal interrupt_dispatcher 'interrupt_dispatcher)
  166.   (set reloc-length (length (lstate-data-reloc *lstate*)))
  167.   (modify (lstate-symbols *lstate*) reverse!)
  168.   (pad-area (lstate-pure *lstate*))
  169.   (pad-area (lstate-impure *lstate*))
  170.   (set pure-size (+area-frontier (lstate-pure *lstate*)))
  171.   (write-header     stream)
  172.   (write-aouthdr stream)
  173.   (write-text-section-header stream)
  174.   (write-data-section-header stream)
  175.   (write-area       stream (lstate-pure *lstate*))
  176.   (write-area       stream (lstate-impure *lstate*))
  177.   (write-relocation stream)
  178.   (receive (i aligned-i) (make-stryng-table)
  179.     (write-cymbal-table-header stream aligned-i)
  180.     (write-hack-local-symbol stream)
  181.     (write-hack-local-string stream)
  182.     (write-stryng-table stream (fx- aligned-i i)))
  183.   (write-hack-file-descriptor stream)
  184.   (write-cymbal-table stream))
  185.  
  186. (define (write-header stream)
  187.     (write-half stream MAGIC)                 ;magic number
  188.     (write-half stream 2)                     ; # of sections
  189.     (write-int stream 0)                      ; time and date 
  190.     (write-int stream (cymbal-table-offset))
  191.     (write-int stream #x60)        ;size of symbol header
  192.     (write-half stream #x38)                      ; size of a.out header
  193.     (write-half stream 0))        ;flags
  194.  
  195. (define (write-aouthdr stream)
  196.   (write-half stream #x107)        ;magic
  197.   (write-half stream #x11f)        ;version stamp
  198.   (write-int stream (text-size))    ;text size
  199.   (write-int stream (data-size))    ;data size
  200.   (write-int stream 0)            ;bss size
  201.   (write-int stream 0)            ;entry
  202.   (write-int stream 0)            ;text base
  203.   (write-int stream (text-size))    ;data base
  204.   (write-int stream (+ (text-size) (data-size))) ;bss base
  205.   (write-int stream 0)            ;register mask
  206.   (write-int stream 0)            ;cp mask [4]
  207.   (write-int stream 0)
  208.   (write-int stream 0)
  209.   (write-int stream 0)
  210.   (write-int stream #x8010))        ;gp value ???
  211.  
  212.  
  213. (define (write-text-section-header stream)   
  214.   (write-string stream ".text")
  215.   (vm-write-byte stream 0)
  216.   (vm-write-byte stream #x20)
  217.   (vm-write-byte stream #x20)
  218.   (write-int stream 0)      ; phys addr
  219.   (write-int stream 0)      ; virtual addr
  220.   (write-int stream (text-size))
  221.   (write-int stream (headers-size))    ;offset in file
  222.   (write-int stream 0)      ; no reloc
  223.   (write-int stream 0)      ; no gp table
  224.   (write-int stream 0)
  225.   (write-int stream #x20))
  226.   
  227. (define (write-data-section-header stream)   
  228.   (write-string stream ".data")
  229.   (vm-write-byte stream 0)
  230.   (vm-write-byte stream #x20)
  231.   (vm-write-byte stream #x20)
  232.   (write-int stream (text-size))      ; phys addr
  233.   (write-int stream (text-size))      ; virtual addr
  234.   (write-int stream (data-size))    
  235.   (write-int stream (+ (text-size) (headers-size)))    ;offset in file
  236.   (write-int stream (+ (headers-size) (text-size) (data-size)))    ;  reloc
  237.   (write-int stream 0)      ; no gp table
  238.   (write-half  stream #xffff)        ;reloc overflow
  239.   (write-half stream 0)            ;no gp table
  240.   (write-half stream #x2000)    ; reloc overflow
  241.   (write-half stream #x40))    ;data flag
  242.  
  243. (define (headers-size) (fx* 39 4))
  244. (define (text-size) (+area-frontier (lstate-pure *lstate*)))
  245. (define (data-size) (+area-frontier (lstate-impure *lstate*)))
  246.  
  247. (define (cymbal-table-offset)
  248.   (+ (headers-size) (text-size) (data-size)
  249.      (* RELOC-SIZE (+ reloc-length 1)))) ;hack number of reloc overflow
  250.  
  251. (define (write-area stream area)
  252.   (walk (lambda (x) (write-store x stream))
  253.         (reverse! (+area-objects area))))
  254.  
  255.  
  256. (define (write-relocation stream)
  257.   (write-int stream (fx+ reloc-length 1))    ;number of relocs
  258.   (write-int stream 0)            ;R_ABS
  259.   (walk (lambda (item)
  260.       (destructure (((addr . (lw .  hb)) item))
  261.         (write-data stream (car item))
  262.         (vm-write-byte stream 0)
  263.         (write-half stream lw)
  264.         (vm-write-byte stream hb)))
  265.         (sort-list! (lstate-data-reloc *lstate*)
  266.                     (lambda (x y)      
  267.                        (fx< (car x) (car y))))))
  268.  
  269.  
  270. (define (write-map-entry stream name value) nil)
  271.  
  272. (define (write-cymbal-table-header stream string-table-size)
  273.   (write-half stream #x7009)        ;magic
  274.   (write-half stream #x11f)        ;vstamp
  275.   (write-long-zeros stream 7)
  276.   (write-int stream 2)            ;number of local symbols
  277.   (write-int stream (+ (cymbal-table-offset) #x60))
  278.   (write-long-zeros stream 4)
  279.   (write-int stream 8)            ;max index in local strings
  280.   (write-int stream (+ (cymbal-table-offset) #x60 24))
  281.   (write-int stream string-table-size)    ;max string-index
  282.   (write-int stream (+ (cymbal-table-offset) #x60 8 24)) ;string table begin
  283.   (write-int stream 1)            ;fd entries
  284.   (write-int stream (+ (cymbal-table-offset) #x60 8 24 string-table-size))
  285.   (write-long-zeros stream 2)
  286.   (write-int stream (lstate-symbol-count *lstate*)) ;max symbol index
  287.   (write-int stream (+ (cymbal-table-offset) #x60 8 24 string-table-size 72)))
  288.  
  289. (define (write-hack-local-symbol stream)
  290.   (write-int stream 1)
  291.   (write-int stream 0)
  292.   (write-int stream #x204b)
  293.   (write-int stream 1)
  294.   (write-int stream 0)
  295.   (write-int stream #x48))
  296.  
  297.  
  298. (define (write-hack-local-string stream)
  299.   (vm-write-byte stream 0)
  300.   (write-string stream "foo.s")
  301.   (vm-write-byte stream 0)
  302.   (vm-write-byte stream 0))
  303.  
  304. (define (write-hack-file-descriptor stream)
  305.   (walk (lambda (x) (write-int stream x))
  306.     '(0 1 0 7 0 2 0 0 0 0 0 0 0 0 0))
  307.   (write-int stream #x223)
  308.   (write-int stream 0)
  309.   (write-int stream 0))
  310.  
  311.  
  312. (define (write-long-zeros stream n)
  313.   (do ((i n (fx- i 1)))
  314.       ((fx= i 0))
  315.     (write-int stream 0)))
  316.  
  317. (define (write-cymbal-table stream)
  318.   (walk (lambda (cym) (cym stream)) (lstate-symbols *lstate*)))
  319.  
  320. (define (make-stryng-table)
  321.   (set the-string-table (make-string-table 'stryngs))
  322.   (iterate loop ((i 0) (cyms (lstate-symbols *lstate*)))
  323.       (cond ((null? cyms) (return i (align i 2)))
  324.             (else
  325.              (let* ((string (cymbal-thunk.stryng (car cyms)))
  326.                     (len (string-length string)))
  327.            (set (table-entry the-string-table string) i)
  328.            (loop (fx+ i (fx+ len 1)) (cdr cyms)))))))
  329.  
  330.  
  331. (define (write-stryng-table stream extra)
  332.   (walk (lambda (cym)
  333.       (write-string stream (cymbal-thunk.stryng cym))
  334.       (vm-write-byte stream 0))
  335.     (lstate-symbols *lstate*))
  336.   (do ((extra extra (fx- extra 1)))
  337.       ((fx= extra 0))
  338.     (vm-write-byte stream 0)))
  339.  
  340.  
  341. (define (pad-area area)
  342.   (let ((rem (fixnum-remainder (+area-frontier area) 16)))
  343.     (cond ((fxn= rem 0)
  344.        (modify (+area-frontier area)
  345.            (lambda (x) (fx+ x (fx- 16 rem))))
  346.        (do ((i (fx- 16 rem) (fx- i 4)))
  347.            ((fx= i 0))
  348.          (push (+area-objects area)
  349.            (object nil
  350.              ((write-store self stream)
  351.               (write-int stream 0)))))))))
  352.